home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pascal / pascal_t.lha / another_wirth next >
Text File  |  1993-07-28  |  67KB  |  1,843 lines
  1. From barbey@disuns2.epfl.ch Fri May 10 09:56:57 1991
  2. Received: from chx400.switch.ch by neuron.tamu.edu (AA22290); Fri, 10 May 91 09:56:14 CDT
  3. X400-Received: by mta chx400.switch.ch in /PRMD=switch/ADMD=arcom/C=CH/;
  4.                Relayed; Fri, 10 May 1991 16:56:56 +0200
  5. X400-Received: by /PRMD=SWITCH/ADMD=ARCOM/C=CH/; Relayed;
  6.                Fri, 10 May 1991 17:52:51 +0200
  7. Date: Fri, 10 May 1991 14:56:56 +0000
  8. X400-Originator: barbey@disuns2.epfl.ch
  9. X400-Mts-Identifier: [/PRMD=SWITCH/ADMD=ARCOM/C=CH/;9105101452.AA02428]
  10. X400-Content-Type: P2-1984 (2)
  11. From: barbey@disuns2.epfl.ch
  12. Message-Id: <9105101452.AA02428@disun15.disuns2.epfl.ch>
  13. To: "(Tim McGuire)" <mcguire@cs.tamu.edu>
  14. Subject: Re: Wirth's Pascal-S compiler
  15. Received: from disun15 by SIC.Epfl.CH via INTERNET ; Fri, 10 May 91 16:53:55 N
  16. Return-Path: <barbey@disuns2.epfl.ch>
  17. Status: R
  18.  
  19. In article <9104241654.AA03830@neuron> you write:
  20. > I am looking for the source for Wirth's Pascal-S compiler.  I'd like to 
  21. > give it to my compiler design students for them to play with.  I have 
  22. > the hardcopy (from Barron's PASCAL: The Language and Its Implementation)
  23. > but, lazy person that I am, I have no desire to type it in.  Does anyone
  24. > have it available, either by ftp or e-mail?   I would prefer the original
  25. > version if possible.  I hear that R.E. Berry did some modifications and
  26. > included them in his book on program translation, but I don't have it 
  27. > available.  Berry's version would be acceptable.  
  28. > 
  29. > I would appreciate any leads you could give me.
  30. > 
  31. > Thanks,
  32. > 
  33. > Tim McGuire
  34. > mcguire@cs.tamu.edu
  35. > -- 
  36.  
  37. You'll find enclosed the source of the original Wirth's PASCAL-S compiler.
  38.  
  39. We use it at the Swiss Institute of Technology - Lausanne (EPFL) in a
  40. Compiler Design Class. The exercise was to transform it in an Object
  41. Pascal... Email me if you need more infos (syntax, ...) on that. 
  42.  
  43. I've been told that Wirth himself still use it in Swiss Institute of Technology
  44. - Zurich for his Compoiler Design Class.
  45.  
  46.  
  47. -Stephane
  48.  
  49.  
  50. --------------------------------------------------------------------------
  51. Stephane Barbey
  52. barbey@eldi.epfl.ch
  53. barbey@disuns2.epfl.ch
  54. --------------------------------------------------------------------------
  55.  
  56. PROGRAM pascals(input,output);  
  57. (*author: n.wirth, e.t.h. ch-8092 zurich, 1.3.76*)  
  58. (* version originale utilisee au cours compilation *)
  59. LABEL 99;
  60. CONST nkw = 27;     (*no. of key words*)
  61.     alng =  12;     (*no. of significant chars in identifiers*) 
  62.     llng = 72;     (*input ,line length*)
  63.     emax = 38;     (*max exponent of real numbers*) 
  64.     emin =-38;     (*min exponent*) 
  65.     kmax =  12;     (*max no. of significant digits*)
  66.     tmax = 100;     (*size of table*)
  67.     bmax =  20;     (*size of block-table*) 
  68.     amax =  30;     (*size of array-table*) 
  69.     c2max = 20;     (*size of real constant table*) 
  70.     csmax = 30;     (*max no. of cases*)
  71.     cmax = 850;     (*size of code*)
  72.     lmax =   7;     (*maximum level*)
  73.     smax = 600;     (*size of string-table*)
  74.     ermax = 58;     (*max error no.*)
  75.     omax =  63;     (*highest order code*)  
  76.     xmax = 32767;  (* 2**15 - 1 (LN) *)
  77.     nmax = maxint;  (* 2**31 - 1 (LN) *) 
  78.     lineleng = 132; (*output line length*)  
  79.     linelimit = 200;
  80.     stacksize = 1450;
  81.  
  82. TYPE symbol = (intcon,realcon,charcon,string,
  83.                notsy,plus,minus,times,idiv,rdiv,imod,andsy,orsy,
  84.                eql,neq,gtr,geq,lss,leq, 
  85.                lparent,rparent,lbrack,rbrack,comma,semicolon,period,
  86.                colon,becomes,constsy,typesy,varsy,functionsy,
  87.                proceduresy,arraysy,recordsy,programsy,ident,
  88.                beginsy,ifsy,casesy,repeatsy,whilesy,forsy,  
  89.                endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,thensy);
  90.  
  91.    pstatus =(run,fin,caschk,divchk,inxchk,stkchk,linchk,lngchk,redchk,  
  92.             iopr,igdm,ifof,ifuf,idof,ioerr,symberr,errcall);
  93.     index  = -xmax .. +xmax;
  94.     alfa = PACKED ARRAY [1..alng] OF char;  
  95.     object = (konstant,variable,type1,prozedure,funktion);  
  96.     types  = (notyp,ints,reals,bools,chars,arrays,records); 
  97.     symset = SET OF symbol; 
  98.     typset = SET OF types;  
  99.     item   = RECORD 
  100.                typ: types; ref: index;  
  101.              END ;  
  102.     order  = PACKED RECORD  
  103.                f: -omax..+omax; 
  104.                x: -lmax..+lmax; 
  105.                y: -1073741824..1073741823; (* (LN) *)
  106.              END ;  
  107.  
  108. VAR sy: symbol;          (*last symbol read by insymbol*)
  109.     id: alfa;            (*identifier from insymbol*)
  110.     inum: integer;       (*integer from insymbol*)  
  111.     rnum: real;          (*real number from insymbol*)  
  112.     sleng: integer;      (*string length*)  
  113.     ch: char;            (*last character read from source program*)
  114.     line: ARRAY [1..llng] OF char;  
  115.     cc: integer;         (*character counter*)  
  116.     lc: integer;         (*program location counter*)
  117.     ll: integer;         (*length of current line*) 
  118.     errs: SET OF 0..ermax;  
  119.     errpos: integer;
  120.     progname: alfa; 
  121.     iflag, oflag, skipflag: boolean;
  122.     constbegsys,typebegsys,blockbegsys,facbegsys,statbegsys: symset;
  123.     key: ARRAY [1..nkw] OF alfa;
  124.     ksy: ARRAY [1..nkw] OF symbol;  
  125.     sps: ARRAY [char] OF symbol;  (*special symbols*)
  126.  
  127.     t,a,b,sx,c1,c2: integer;  (*indices to tables*) 
  128.     stantyps: typset;
  129.     display: ARRAY [0 .. lmax] OF integer;  
  130.  
  131.     tab:     ARRAY [0 .. tmax] OF     (*identifier table*)  
  132.                PACKED RECORD
  133.                  name: alfa;  link: index;  
  134.                  obj: object; typ: types;
  135.                  ref: index;  normal: boolean;  
  136.                  lev: 0 .. lmax; adr: integer;  
  137.                END ;
  138.     atab:    ARRAY [1 .. amax] OF     (*array-table*)
  139.                PACKED RECORD
  140.                  inxtyp, eltyp: types;  
  141.                  elref, low, high, elsize, size: index; 
  142.                END ;
  143.     btab:    ARRAY [1 .. bmax] OF    (*block-table*)
  144.                PACKED RECORD
  145.                   last, lastpar, psize, vsize: index
  146.                END ;
  147.     stab:    PACKED ARRAY [0..smax] OF char;  (*string table*)  
  148.     rconst:  ARRAY [1 .. c2max] OF real;
  149.     code:    ARRAY [0 .. cmax] OF order;
  150.  
  151.     ps : pstatus;
  152.  
  153. PROCEDURE errormsg; 
  154.    VAR k: integer;  
  155.        msg: ARRAY [0..ermax] OF alfa;
  156. BEGIN
  157.   msg[ 0] := 'undef id    '; msg[ 1] := 'multi def   '; 
  158.   msg[ 2] := 'identifier  '; msg[ 3] := 'program     '; 
  159.   msg[ 4] := ')           '; msg[ 5] := ':           '; 
  160.   msg[ 6] := 'syntax      '; msg[ 7] := 'ident, var  '; 
  161.   msg[ 8] := 'of          '; msg[ 9] := '(           '; 
  162.   msg[10] := 'id, array   '; msg[11] := '[           '; 
  163.   msg[12] := ']           '; msg[13] := '..          '; 
  164.   msg[14] := ';           '; msg[15] := 'func. type  '; 
  165.   msg[16] := '=           '; msg[17] := 'boolean     '; 
  166.   msg[18] := 'convar typ  '; msg[19] := 'type        '; 
  167.   msg[20] := 'prog.param  '; msg[21] := 'too big     '; 
  168.   msg[22] := '.           '; msg[23] := 'typ (case)  '; 
  169.   msg[24] := 'character   '; msg[25] := 'const id    '; 
  170.   msg[26] := 'index type  '; msg[27] := 'indexbound  '; 
  171.   msg[28] := 'no array    '; msg[29] := 'type id     '; 
  172.   msg[30] := 'undef type  '; msg[31] := 'no record   '; 
  173.   msg[32] := 'boole type  '; msg[33] := 'arith type  '; 
  174.   msg[34] := 'integer     '; msg[35] := 'types       '; 
  175.   msg[36] := 'param type  '; msg[37] := 'variab id   '; 
  176.   msg[38] := 'string      '; msg[39] := 'no.of pars  '; 
  177.   msg[40] := 'real numbr  '; msg[41] := 'type        '; 
  178.   msg[42] := 'real type   '; msg[43] := 'integer     '; 
  179.   msg[44] := 'var, const  '; msg[45] := 'var, proc   '; 
  180.   msg[46] := 'types (:=)  '; msg[47] := 'typ (case)  '; 
  181.   msg[48] := 'type        '; msg[49] := 'store ovfl  '; 
  182.   msg[50] := 'constant    '; msg[51] := ':=          '; 
  183.   msg[52] := 'then        '; msg[53] := 'until       '; 
  184.   msg[54] := 'do          '; msg[55] := 'to downto   '; 
  185.   msg[56] := 'begin       '; msg[57] := 'end         '; 
  186.   msg[58] := 'factor      ';
  187.   k := 0; writeln; writeln(' key words');
  188.   WHILE errs <> [] DO
  189.   BEGIN WHILE NOT (k IN errs) DO k := k+1;  
  190.         writeln(k,'  ',msg[k]); errs := errs - [k]  
  191.   END
  192. END (*errormsg*) ;  
  193.  
  194. PROCEDURE endskip;  
  195. BEGIN (*underline skipped part of input*)
  196.    WHILE errpos < cc DO 
  197.       BEGIN write('-'); errpos := errpos + 1
  198.       END ; 
  199.    skipflag := false
  200. END (*endskip*) ;
  201.  
  202. PROCEDURE nextch;   (*read next character; process line end*)
  203. BEGIN IF cc = ll THEN
  204.       BEGIN IF eof(input) THEN  
  205.             BEGIN writeln;  
  206.                writeln(' program incomplete');  
  207.                errormsg; GOTO 99
  208.             END ;
  209.          IF errpos <> 0 THEN
  210.             BEGIN IF skipflag THEN endskip; 
  211.                writeln; errpos := 0 
  212.             END ;
  213.          write(lc:5, '  '); 
  214.          ll := 0; cc := 0;  
  215.          WHILE NOT eoln(input) DO
  216.             BEGIN ll := ll+1; read(ch); write(ch); line[ll] := ch
  217.             END ;
  218.          writeln; ll := ll+1; line[ll]:=' '; readln 
  219.       END ; 
  220.    cc := cc+1; ch := line[cc];  
  221. END (*nextch*) ;
  222.  
  223. PROCEDURE error(n: integer);
  224. BEGIN IF errpos = 0 THEN write(' ****');
  225.    IF cc > errpos THEN  
  226.       BEGIN write(' ': cc-errpos, '^', n:2);
  227.          errpos := cc+3; errs := errs + [n] 
  228.       END
  229. END (*error*) ; 
  230.  
  231. PROCEDURE fatal(n: integer);
  232.    VAR msg: ARRAY [1..7] OF alfa;
  233. BEGIN writeln; errormsg;
  234.    msg[ 1] := 'identifier  '; msg[ 2] := 'procedures  ';
  235.    msg[ 3] := 'reals       '; msg[ 4] := 'arrays      ';
  236.    msg[ 5] := 'levels      '; msg[ 6] := 'code        ';
  237.    msg[ 7] := 'strings     ';
  238.    writeln(' compiler table for ', msg[n], ' is too small');
  239.    GOTO 99    (* terminate compilation*)
  240. END (*fatal*) ; 
  241.  
  242. (*-----------------------------------------------------------insymbol-*)
  243. PROCEDURE insymbol;           (*reads next symbol*) 
  244.    LABEL 1,2,3; 
  245.    VAR i,j,k,e: integer;
  246.  
  247.    PROCEDURE readscale; 
  248.       VAR s, sign: integer; 
  249.    BEGIN nextch; sign := 1; s := 0; 
  250.       IF ch = '+' THEN nextch ELSE  
  251.       IF ch = '-' THEN BEGIN nextch; sign := -1 END ;
  252.       IF NOT (ch IN ['0'..'9']) THEN error(40)  
  253.       ELSE REPEAT s := 10*s + ord(ch) - ord('0'); nextch
  254.            UNTIL NOT (ch IN ['0'..'9']);
  255.       e := s*sign + e
  256.    END (*readscale*) ;  
  257.  
  258.    PROCEDURE adjustscale;
  259.       VAR s: integer; d,t: real;
  260.    BEGIN IF k+e > emax THEN error(21) ELSE  
  261.          IF k+e < emin THEN rnum := 0 ELSE  
  262.      BEGIN s := abs(e); t := 1.0; d := 10.0;
  263.        REPEAT
  264.          WHILE NOT odd(s) DO
  265.             BEGIN s := s DIV 2; d := sqr(d) 
  266.             END ;
  267.          s := s-1; t := d*t 
  268.        UNTIL s = 0; 
  269.        IF e >= 0 THEN rnum := rnum*t ELSE rnum := rnum/t
  270.      END
  271.    END (*adjustscale*) ;
  272.  
  273. BEGIN (*insymbol*)  
  274. 1: WHILE ch = ' ' DO nextch;
  275.    CASE ch OF
  276. 'a','b','c','d','e','f','g','h','i',
  277. 'j','k','l','m','n','o','p','q','r',
  278. 's','t','u','v','w','x','y','z',
  279. 'A','B','C','D','E','F','G','H','I',
  280. 'J','K','L','M','N','O','P','Q','R',
  281. 'S','T','U','V','W','X','Y','Z':
  282.    BEGIN (*identifier or wordsymbol*)  k := 0; id := '            ';
  283.       REPEAT IF k < alng THEN
  284.              BEGIN k := k+1;
  285.                IF ch IN ['A'..'Z'] THEN
  286.                  id[k]:=chr(ord(ch)+ord('a')-ord('A'))
  287.                ELSE id[k] := ch
  288.              END ;  
  289.          nextch 
  290.       UNTIL NOT (ch IN ['a'..'z','A'..'Z','0'..'9']);
  291.       i := 1; j := nkw;   (*binary search*) 
  292.       REPEAT k := (i+j) DIV 2;  
  293.          IF id <= key[k] THEN j := k-1; 
  294.          IF id >= key[k] THEN i := k+1  
  295.       UNTIL i > j;  
  296.       IF i-1 > j THEN sy := ksy[k] ELSE sy := ident 
  297.    END; 
  298. '0','1','2','3','4','5','6','7','8','9':
  299.    BEGIN (*number*) k := 0; inum := 0; sy := intcon;
  300.       REPEAT inum := inum*10 + ord(ch) - ord('0');  
  301.          k := k+1; nextch
  302.       UNTIL NOT (ch IN ['0'..'9']); 
  303.       IF (k > kmax) OR (inum > nmax) THEN
  304.         BEGIN error(21); inum := 0; k := 0  
  305.         END ;
  306.       IF ch = '.' THEN  
  307.       BEGIN nextch; 
  308.          IF ch = '.' THEN ch := ':' ELSE
  309.             BEGIN sy := realcon; rnum := inum; e := 0;  
  310.                WHILE ch IN ['0'..'9'] DO
  311.                BEGIN e := e-1;  
  312.                   rnum := 10.0*rnum + (ord(ch)-ord('0')); nextch
  313.                END ;
  314.                IF e = 0 THEN error(40); 
  315.                IF ch IN ['e','E'] THEN readscale;  
  316.                IF e <> 0 THEN adjustscale
  317.             END 
  318.       END ELSE  
  319.       IF ch IN ['e','E'] THEN
  320.       BEGIN sy := realcon; rnum := inum; e := 0;
  321.          readscale; IF e <> 0 THEN adjustscale  
  322.       END ; 
  323.    END; 
  324. ':': BEGIN nextch;  
  325.           IF ch = '=' THEN  
  326.             BEGIN sy := becomes; nextch 
  327.             END  ELSE sy := colon
  328.       END ; 
  329. '<' : BEGIN nextch; 
  330.          IF ch = '=' THEN BEGIN sy := leq; nextch END ELSE  
  331.          IF ch = '>' THEN BEGIN sy := neq; nextch END ELSE sy := lss
  332.       END ; 
  333. '>' : BEGIN nextch; 
  334.          IF ch = '=' THEN BEGIN sy := geq; nextch END ELSE sy := gtr
  335.       END ; 
  336. '.' : BEGIN nextch; 
  337.          IF ch = '.' THEN
  338.             BEGIN sy := colon; nextch
  339.             END  ELSE sy := period  
  340.       END ; 
  341. '''': BEGIN k := 0; 
  342.     2:  nextch; 
  343.         IF ch = '''' THEN
  344.           BEGIN nextch; IF ch <> '''' THEN GOTO 3
  345.           END ; 
  346.         IF sx+k = smax THEN fatal(7);
  347.         stab[sx+k] := ch; k := k+1; 
  348.         IF cc = 1 THEN  
  349.           BEGIN (*end of line*) k := 0; 
  350.           END
  351.         ELSE GOTO 2;
  352.     3:  IF k = 1 THEN
  353.            BEGIN sy := charcon; inum := ord(stab[sx])
  354.            END ELSE 
  355.         IF k = 0 THEN
  356.            BEGIN error(38); sy := charcon; inum := 0
  357.            END ELSE 
  358.            BEGIN sy := string; inum := sx; sleng := k; sx := sx+k
  359.            END  
  360.       END ; 
  361. '(' : BEGIN nextch; 
  362.          IF ch <> '*' THEN sy := lparent ELSE
  363.          BEGIN (*comment*) nextch;  
  364.             REPEAT  
  365.                WHILE ch <> '*' DO nextch;
  366.                nextch
  367.             UNTIL ch = ')'; 
  368.             nextch; GOTO 1  
  369.          END
  370.       END ; 
  371. '+', '-', '*', '/', ')', '=', ',', '[', ']', ';' :  
  372.       BEGIN sy := sps[ch]; nextch
  373.       END ; 
  374. '$', '!', '@', '\', '^', '_', '?',  '"', '&', '#',
  375. '%', '{', '}', '~', '`', '|' :  
  376.       BEGIN error(24); nextch; GOTO 1
  377.       END
  378.    END  
  379. END (*insymbol*) ;  
  380.  
  381. (*---------------------------------------------------------- enter ---*)
  382.  
  383. PROCEDURE enter(x0: alfa; x1: object;
  384.                 x2: types; x3: integer);
  385. BEGIN t := t+1;   (*enter standard identifier*) 
  386.    WITH tab[t] DO
  387.    BEGIN name := x0; link := t-1; obj := x1;
  388.       typ := x2; ref := 0; normal := true;  
  389.       lev := 0; adr := x3
  390.    END  
  391. END (*enter*) ; 
  392.  
  393. PROCEDURE enterarray(tp: types; l,h: integer);  
  394. BEGIN IF l > h THEN error(27);  
  395.    IF (abs(l)>xmax) OR (abs(h)>xmax) THEN
  396.       BEGIN error(27); l := 0; h := 0;  
  397.       END ; 
  398.    IF a = amax THEN fatal(4) ELSE
  399.       BEGIN a := a+1;
  400.         WITH atab[a] DO 
  401.             BEGIN inxtyp := tp; low := l; high := h 
  402.             END 
  403.       END
  404. END (*enterarray*) ;
  405.  
  406. PROCEDURE enterblock;
  407. BEGIN IF b = bmax THEN fatal(2) ELSE
  408.       BEGIN b := b+1; btab[b].last := 0; btab[b].lastpar := 0
  409.       END
  410. END (*enterblock*) ;
  411.  
  412. PROCEDURE enterreal(x: real);
  413. BEGIN IF c2 = c2max-1 THEN fatal(3) ELSE
  414.       BEGIN rconst[c2+1] := x; c1 := 1; 
  415.          WHILE rconst[c1] <> x DO  c1 := c1+1;  
  416.          IF c1 > c2 THEN c2 := c1
  417.       END
  418. END (*enterreal*) ; 
  419.  
  420. PROCEDURE emit(fct: integer);
  421. BEGIN IF lc = cmax THEN fatal(6);
  422.    code[lc].f := fct; lc := lc+1
  423. END (*emit*) ;  
  424.  
  425. PROCEDURE emit1(fct,b: integer);
  426. BEGIN IF lc = cmax THEN fatal(6);
  427.    WITH code[lc] DO 
  428.       BEGIN f := fct; y := b END ;  
  429.    lc := lc+1
  430. END (*emit1*) ; 
  431.  
  432. PROCEDURE emit2(fct,a,b: integer);  
  433. BEGIN IF lc = cmax THEN fatal(6);
  434.    WITH code[lc] DO 
  435.      BEGIN f := fct; x := a; y := b END ;
  436.    lc := lc+1
  437. END (*emit2*) ; 
  438.  
  439. PROCEDURE printtables;  
  440.    VAR i: integer; o: order;
  441. BEGIN
  442.  page(output);  
  443.    writeln(' identifiers          link  obj  typ  ref  nrm  lev  adr'); 
  444.    FOR i := btab[1].last +1 TO t DO 
  445.       WITH tab[i] DO
  446.       writeln(i:7,' ',name,link:5, ord(obj):5, ord(typ):5, ref:5,
  447.             ord(normal):5, lev:5, adr:5);
  448.        writeln; 
  449.    writeln(' blocks    last lpar psze vsze');
  450.    FOR i := 1 TO b DO
  451.       WITH btab[i] DO
  452.       writeln(i:5,'    ', last:5, lastpar:5, psize:5, vsize:5); 
  453.        writeln; 
  454.    writeln(' arrays    xtyp etyp eref  low high elsz size');
  455.    FOR i := 1 TO a DO
  456.       WITH atab[i] DO
  457.       writeln(i:5,'    ', ord(inxtyp):5, ord(eltyp):5,  
  458.               elref:5, low:5, high:5, elsize:5, size:5);
  459.        writeln; 
  460.    writeln(' code:');
  461.    FOR i := 0 TO lc-1 DO
  462.    BEGIN IF i MOD 5 = 0 THEN
  463.          BEGIN writeln; write(i:5)  
  464.          END ;  
  465.       o := code[i]; write(o.f:5);
  466.       IF o.f < 31 THEN  
  467.         IF o.f < 4 THEN write(o.x:2, o.y:5) 
  468.                     ELSE write(o.y:7)
  469.       ELSE write('       ');
  470.       write(',')
  471.    END ;
  472.    writeln  
  473. END (*printtables*) ;
  474.  
  475. (*-------------------------------------------------------------block--*)
  476.  
  477. PROCEDURE block(fsys: symset; isfun: boolean; level: integer);  
  478.  
  479.    TYPE conrec =
  480.       RECORD CASE tp: types OF  
  481.          ints,chars,bools: (i: integer);
  482.          reals: (r: real)
  483.       END ; 
  484.  
  485.    VAR dx: integer;    (*data allocation index*)
  486.        prt: integer;   (*t-index of this procedure*)
  487.        prb: integer;   (*b-index of this procedure*)
  488.        x: integer;  
  489.  
  490.    PROCEDURE skip(fsys: symset; n: integer);
  491.    BEGIN error(n); skipflag := true;
  492.       WHILE NOT (sy IN fsys) DO insymbol;
  493.       IF skipflag THEN endskip  
  494.    END (*skip*) ;
  495.  
  496.    PROCEDURE test(s1,s2: symset; n: integer);
  497.    BEGIN IF NOT (sy IN s1) THEN 
  498.          skip(s1+s2,n)  
  499.    END (*test*) ;
  500.  
  501.    PROCEDURE testsemicolon; 
  502.    BEGIN
  503.      IF sy = semicolon THEN insymbol ELSE
  504.      BEGIN error(14);
  505.        IF sy IN [comma,colon] THEN insymbol 
  506.      END ;  
  507.      test([ident]+blockbegsys, fsys, 6) 
  508.    END (*testsemicolon*) ;  
  509.    PROCEDURE enter(id: alfa; k: object);
  510.       VAR j,l: integer; 
  511.    BEGIN IF t = tmax THEN fatal(1) ELSE 
  512.          BEGIN tab[0].name := id;
  513.             j := btab[display[level]].last;  l := j;
  514.             WHILE tab[j].name <> id DO  j := tab[j].link;
  515.             IF j <> 0 THEN error(1) ELSE
  516.             BEGIN t := t+1; 
  517.               WITH tab[t] DO
  518.               BEGIN name := id; link := l;  
  519.                obj := k; typ := notyp; ref := 0; lev := level; adr := 0 
  520.               END ; 
  521.               btab[display[level]].last := t
  522.             END 
  523.          END
  524.    END (*enter*) ;  
  525.  
  526.    FUNCTION loc(id: alfa): integer; 
  527.       VAR i,j: integer;     (*locate id in table*)  
  528.    BEGIN i := level; tab[0].name := id;   (*sentinel*)  
  529.       REPEAT j := btab[display[i]].last;
  530.          WHILE tab[j].name <> id DO  j := tab[j].link;  
  531.          i := i-1;  
  532.       UNTIL (i<0) OR (j<>0);
  533.       IF j = 0 THEN error(0);  loc := j 
  534.    END (*loc*) ;
  535.  
  536.   PROCEDURE entervariable;  
  537.   BEGIN IF sy = ident THEN  
  538.           BEGIN enter(id,variable); insymbol
  539.           END
  540.         ELSE error(2)
  541.   END (*entervariable*) ;
  542.  
  543.    PROCEDURE constant(fsys: symset; VAR c: conrec); 
  544.      VAR x, sign: integer;  
  545.    BEGIN c.tp := notyp; c.i := 0;
  546.      test(constbegsys, fsys, 50);
  547.      IF sy IN constbegsys THEN  
  548.      BEGIN  
  549.          IF sy = charcon THEN
  550.            BEGIN c.tp := chars; c.i := inum; insymbol
  551.            END  
  552.          ELSE
  553.            BEGIN sign := 1; 
  554.              IF sy IN [plus,minus] THEN 
  555.                BEGIN IF sy = minus THEN sign := -1; 
  556.                  insymbol
  557.                END ;
  558.              IF sy = ident THEN 
  559.                BEGIN x := loc(id);  
  560.                  IF x <> 0 THEN 
  561.                    IF tab[x].obj <> konstant THEN error(25) ELSE
  562.                    BEGIN c.tp := tab[x].typ;
  563.                      IF c.tp = reals THEN c.r := sign*rconst[tab[x].adr]
  564.                                      ELSE c.i := sign*tab[x].adr
  565.                    END ;
  566.                  insymbol
  567.                END  
  568.              ELSE
  569.              IF sy = intcon THEN
  570.                BEGIN c.tp := ints; c.i := sign*inum; insymbol
  571.                END ELSE 
  572.              IF sy = realcon THEN
  573.                BEGIN c.tp := reals; c.r := sign*rnum; insymbol  
  574.                END ELSE skip(fsys,50)
  575.            END; 
  576.          test(fsys, [], 6)  
  577.        END  
  578.    END (*constant*) ;
  579.  
  580.    PROCEDURE typ(fsys: symset; VAR tp: types; VAR rf, sz: integer); 
  581.      VAR x: integer;
  582.          eltp: types; elrf: integer;
  583.          elsz, offset, t0,t1: integer;  
  584.  
  585.      PROCEDURE arraytyp(VAR aref,arsz: integer);
  586.         VAR eltp: types;
  587.            low, high: conrec;
  588.            elrf, elsz: integer; 
  589.      BEGIN constant([colon,rbrack,rparent,ofsy]+fsys, low); 
  590.         IF low.tp = reals THEN  
  591.            BEGIN error(27); low.tp := ints; low.i := 0  
  592.            END ;
  593.         IF sy = colon THEN insymbol ELSE error(13); 
  594.         constant([rbrack,comma,rparent,ofsy]+fsys, high);
  595.         IF high.tp <> low.tp THEN
  596.            BEGIN error(27); high.i := low.i 
  597.            END ;
  598.         enterarray(low.tp, low.i, high.i); aref := a;
  599.         IF sy = comma THEN  
  600.            BEGIN insymbol; eltp := arrays; arraytyp(elrf,elsz)  
  601.            END ELSE 
  602.         BEGIN
  603.            IF sy = rbrack THEN insymbol ELSE
  604.               BEGIN error(12);  
  605.                  IF sy = rparent THEN insymbol  
  606.               END ; 
  607.            IF sy = ofsy THEN insymbol ELSE error(8);
  608.            typ(fsys,eltp,elrf,elsz) 
  609.         END ;
  610.         WITH atab[aref] DO  
  611.         BEGIN arsz := (high-low+1)*elsz; size := arsz;  
  612.            eltyp := eltp; elref := elrf; elsize := elsz 
  613.         END ;
  614.      END (*arraytyp*) ; 
  615.  
  616.    BEGIN (*typ*) tp := notyp; rf := 0; sz := 0; 
  617.      test(typebegsys, fsys, 10);
  618.      IF sy IN typebegsys THEN
  619.        BEGIN
  620.          IF sy = ident THEN 
  621.          BEGIN x := loc(id);
  622.            IF x <> 0 THEN
  623.            WITH tab[x] DO
  624.              IF obj <> type1 THEN error(29) ELSE
  625.              BEGIN tp := typ; rf := ref; sz := adr; 
  626.                IF tp = notyp THEN error(30) 
  627.              END ;  
  628.            insymbol 
  629.          END ELSE
  630.          IF sy = arraysy THEN
  631.          BEGIN insymbol;
  632.              IF sy = lbrack THEN insymbol ELSE  
  633.                 BEGIN error(11);
  634.                    IF sy = lparent THEN insymbol
  635.                 END ;
  636.              tp := arrays; arraytyp(rf,sz)  
  637.          END ELSE
  638.          BEGIN (*records*) insymbol;
  639.            enterblock; tp := records; rf := b;  
  640.            IF level = lmax THEN fatal(5);
  641.            level := level+1; display[level] := b; offset := 0;  
  642.            WHILE NOT (sy IN fsys-[semicolon,comma,ident]+[endsy]) DO
  643.            BEGIN (*field section*)  
  644.              IF sy = ident THEN 
  645.              BEGIN t0 := t; entervariable;  
  646.                WHILE sy = comma DO  
  647.                  BEGIN insymbol; entervariable  
  648.                  END ;  
  649.                IF sy = colon THEN insymbol ELSE error(5);
  650.                t1 := t; 
  651.                typ(fsys+[semicolon,endsy,comma,ident],eltp,elrf,elsz);  
  652.                WHILE t0 < t1 DO 
  653.                BEGIN t0 := t0+1;
  654.                  WITH tab[t0] DO
  655.                  BEGIN typ := eltp; ref := elrf; normal := true;
  656.                    adr := offset; offset := offset + elsz
  657.                  END
  658.                END  
  659.              END ;  
  660.              IF sy <> endsy THEN
  661.              BEGIN IF sy = semicolon THEN insymbol ELSE 
  662.                    BEGIN error(14); 
  663.                      IF sy = comma THEN insymbol
  664.                    END ;
  665.                 test([ident,endsy,semicolon], fsys, 6)  
  666.              END
  667.            END ;
  668.            btab[rf].vsize := offset; sz := offset; btab[rf].psize := 0; 
  669.            insymbol; level := level-1
  670.          END ;  
  671.          test(fsys, [], 6)  
  672.        END  
  673.    END (*typ*) ;
  674.  
  675.    PROCEDURE parameterlist;     (*formal parameter list*)
  676.       VAR tp: types;
  677.           rf, sz, x, t0: integer;
  678.           valpar: boolean;  
  679.    BEGIN insymbol; tp := notyp; rf := 0; sz := 0;
  680.      test([ident, varsy], fsys+[rparent], 7);
  681.      WHILE sy IN [ident,varsy] DO
  682.        BEGIN IF sy <> varsy THEN valpar := true ELSE
  683.                BEGIN insymbol; valpar := false  
  684.                END ;
  685.          t0 := t; entervariable;
  686.          WHILE sy = comma DO
  687.             BEGIN insymbol; entervariable;  
  688.             END ;
  689.          IF sy = colon THEN 
  690.            BEGIN insymbol;  
  691.              IF sy <> ident THEN error(2) ELSE  
  692.              BEGIN x := loc(id); insymbol;  
  693.                IF x <> 0 THEN
  694.                WITH tab[x] DO
  695.                  IF obj <> type1 THEN error(29) ELSE
  696.                    BEGIN tp := typ; rf := ref;  
  697.                      IF valpar THEN sz := adr ELSE sz := 1  
  698.                    END ;
  699.              END ;  
  700.              test([semicolon,rparent], [comma,ident]+fsys, 14)  
  701.            END  
  702.          ELSE error(5); 
  703.          WHILE t0 < t DO
  704.          BEGIN t0 := t0+1;  
  705.            WITH tab[t0] DO  
  706.            BEGIN typ := tp; ref := rf;  
  707.                normal := valpar; adr := dx; lev := level;
  708.                dx := dx + sz
  709.            END  
  710.          END ;  
  711.          IF sy <> rparent THEN  
  712.          BEGIN IF sy = semicolon THEN insymbol ELSE 
  713.                BEGIN error(14); 
  714.                  IF sy = comma THEN insymbol
  715.                END ;
  716.             test([ident,varsy], [rparent]+fsys, 6)  
  717.          END
  718.        END (*while*) ;  
  719.      IF sy = rparent THEN
  720.        BEGIN insymbol;  
  721.          test([semicolon,colon], fsys, 6)
  722.        END  
  723.      ELSE error(4)  
  724.    END (*parameterlist*) ;  
  725.  
  726.    PROCEDURE constantdeclaration;
  727.      VAR c: conrec; 
  728.    BEGIN insymbol;  
  729.      test([ident], blockbegsys, 2); 
  730.      WHILE sy = ident DO
  731.        BEGIN enter(id,konstant); insymbol;  
  732.          IF sy = eql THEN insymbol ELSE 
  733.             BEGIN error(16);
  734.                IF sy = becomes THEN insymbol
  735.             END ;
  736.          constant([semicolon,comma,ident]+fsys,c);  
  737.          tab[t].typ := c.tp; tab[t].ref := 0;
  738.          IF c.tp = reals THEN
  739.            BEGIN enterreal(c.r); tab[t].adr := c1 END
  740.          ELSE tab[t].adr := c.i;
  741.          testsemicolon  
  742.        END  
  743.    END (*constantdeclaration*) ;
  744.  
  745.    PROCEDURE typedeclaration;
  746.      VAR tp: types; rf, sz, t1: integer;
  747.    BEGIN insymbol;  
  748.      test([ident], blockbegsys, 2); 
  749.      WHILE sy = ident DO
  750.        BEGIN enter(id,type1); t1 := t; insymbol;
  751.          IF sy = eql THEN insymbol ELSE 
  752.             BEGIN error(16);
  753.                IF sy = becomes THEN insymbol
  754.             END ;
  755.          typ([semicolon,comma,ident]+fsys, tp, rf, sz); 
  756.          WITH tab[t1] DO
  757.            BEGIN typ := tp; ref := rf; adr := sz
  758.            END ;
  759.          testsemicolon  
  760.        END  
  761.    END (*typedeclaration*) ;
  762.  
  763.    PROCEDURE variabledeclaration;
  764.      VAR t0, t1, rf, sz: integer;
  765.          tp: types; 
  766.    BEGIN insymbol;  
  767.      WHILE sy = ident DO
  768.      BEGIN t0 := t; entervariable;  
  769.        WHILE sy = comma DO  
  770.          BEGIN insymbol; entervariable; 
  771.          END ;  
  772.        IF sy = colon THEN insymbol ELSE error(5);
  773.        t1 := t; 
  774.        typ([semicolon,comma,ident]+fsys, tp, rf, sz);
  775.        WHILE t0 < t1 DO 
  776.        BEGIN t0 := t0+1;
  777.          WITH tab[t0] DO
  778.          BEGIN typ := tp; ref := rf;
  779.            lev := level; adr := dx; normal := true; 
  780.            dx := dx + sz
  781.          END
  782.        END ;
  783.        testsemicolon
  784.      END
  785.    END (*variabledeclaration*) ;
  786.  
  787.    PROCEDURE procdeclaration;
  788.       VAR isfun: boolean;
  789.    BEGIN isfun := sy = functionsy; insymbol;
  790.      IF sy <> ident THEN
  791.         BEGIN  error(2); id := '            '
  792.         END ;
  793.      IF isfun THEN enter(id,funktion) ELSE enter(id,prozedure); 
  794.      tab[t].normal := true; 
  795.      insymbol; block([semicolon]+fsys, isfun, level+1); 
  796.      IF sy = semicolon THEN insymbol ELSE error(14);
  797.      emit(32+ord(isfun))    (*exit*)
  798.    END (*proceduredeclaration*) ;
  799.  
  800. (*---------------------------------------------------------statement--*)
  801.    
  802.  
  803.    PROCEDURE statement(fsys: symset);
  804.       VAR i: integer; (* x: item; (LN) *) 
  805.  
  806.      PROCEDURE expression(fsys: symset; VAR x: item); forward; 
  807.  
  808.       PROCEDURE selector(fsys: symset; VAR v:item); 
  809.          VAR x: item; a,j: integer; 
  810.       BEGIN (*sy in [lparent, lbrack, period]*) 
  811.         REPEAT  
  812.           IF sy = period THEN
  813.           BEGIN insymbol;  (*field selector*)
  814.             IF sy <> ident THEN error(2) ELSE
  815.             BEGIN
  816.               IF v.typ <> records THEN error(31) ELSE
  817.               BEGIN (*search field identifier*) 
  818.                 j := btab[v.ref] .last; tab[0].name := id;  
  819.                 WHILE tab[j].name <> id DO j := tab[j].link;
  820.                 IF j = 0 THEN error(0); 
  821.                 v.typ := tab[j].typ; v.ref := tab[j].ref;
  822.                 a := tab[j].adr; IF a <> 0 THEN emit1(9,a)  
  823.               END ; 
  824.               insymbol  
  825.             END 
  826.           END ELSE  
  827.           BEGIN (*array selector*)  
  828.             IF sy <> lbrack THEN error(11); 
  829.             REPEAT insymbol;
  830.               expression(fsys+[comma,rbrack], x);
  831.               IF v.typ <> arrays THEN error(28) ELSE
  832.                 BEGIN a := v.ref;
  833.                   IF atab[a].inxtyp <> x.typ THEN error(26) ELSE
  834.                 IF atab[a].elsize = 1 THEN emit1(20,a) ELSE emit1(21,a);
  835.                   v.typ := atab[a].eltyp; v.ref := atab[a].elref
  836.                 END 
  837.             UNTIL sy <> comma;  
  838.             IF sy = rbrack THEN insymbol ELSE
  839.               BEGIN error(12); IF sy = rparent THEN insymbol
  840.               END
  841.           END
  842.         UNTIL NOT (sy IN [lbrack,lparent,period]);  
  843.         test(fsys, [], 6)
  844.       END (*selector*) ;
  845.  
  846.       PROCEDURE call(fsys: symset; i: integer); 
  847.          VAR x: item;
  848.              lastp, cp, k: integer; 
  849.       BEGIN emit1(18,i);  (*mark stack*)
  850.         lastp := btab[tab[i].ref].lastpar; cp := i; 
  851.         IF sy = lparent THEN
  852.         BEGIN (*actual parameter list*) 
  853.           REPEAT insymbol;  
  854.             IF cp >= lastp THEN error(39) ELSE  
  855.             BEGIN cp := cp+1;
  856.               IF tab[cp].normal THEN
  857.               BEGIN (*value parameter*) 
  858.                 expression(fsys+[comma,colon,rparent], x);  
  859.                 IF x.typ=tab[cp].typ THEN
  860.                   BEGIN 
  861.                     IF x.ref <> tab[cp].ref THEN error(36) ELSE 
  862.                   IF x.typ = arrays THEN emit1(22,atab[x.ref].size) ELSE
  863.                     IF x.typ = records THEN emit1(22,btab[x.ref].vsize) 
  864.                   END ELSE  
  865.                 IF (x.typ=ints) AND (tab[cp].typ=reals) THEN
  866.                    emit1(26,0) ELSE 
  867.                    IF x.typ<>notyp THEN error(36);  
  868.               END ELSE  
  869.               BEGIN (*variable parameter*)  
  870.                 IF sy <> ident THEN error(2) ELSE
  871.                 BEGIN k := loc(id); insymbol;
  872.                   IF k <> 0 THEN
  873.                   BEGIN IF tab[k].obj <> variable THEN error(37);
  874.                     x.typ := tab[k].typ; x.ref := tab[k].ref;
  875.                     IF tab[k].normal THEN emit2(0,tab[k].lev,tab[k].adr)
  876.                        ELSE emit2(1,tab[k].lev,tab[k].adr); 
  877.                     IF sy IN [lbrack,lparent,period] THEN
  878.                        selector(fsys+[comma,colon,rparent], x); 
  879.                     IF (x.typ<>tab[cp].typ) OR (x.ref<>tab[cp].ref) THEN
  880.                        error(36)
  881.                   END
  882.                 END 
  883.               END
  884.             END ;
  885.             test([comma,rparent], fsys, 6)  
  886.           UNTIL sy <> comma;
  887.           IF sy = rparent THEN insymbol ELSE error(4)
  888.         END ;
  889.         IF cp < lastp THEN error(39); (*too few actual parameters*) 
  890.         emit1(19, btab[tab[i].ref].psize-1);
  891.         IF tab[i].lev < level THEN emit2(3, tab[i].lev, level)  
  892.       END (*call*) ;
  893.  
  894.       FUNCTION resulttype(a,b: types): types;
  895.       BEGIN 
  896.         IF (a>reals) OR (b>reals) THEN  
  897.           BEGIN error(33); resulttype := notyp  
  898.           END ELSE  
  899.         IF (a=notyp) OR (b=notyp) THEN resulttype := notyp ELSE 
  900.         IF a=ints THEN  
  901.           IF b=ints THEN resulttype := ints ELSE
  902.             BEGIN resulttype := reals; emit1(26,1)  
  903.             END 
  904.         ELSE
  905.           BEGIN resulttype := reals;
  906.             IF b=ints THEN emit1(26,0)  
  907.           END
  908.       END (*resulttype*) ;  
  909.  
  910.       PROCEDURE expression; (* (LN) *) 
  911.         VAR y:item; op:symbol;  
  912.  
  913.         PROCEDURE simpleexpression(fsys:symset; VAR x:item);
  914.           VAR y:item; op:symbol;
  915.  
  916.           PROCEDURE term(fsys:symset; VAR x:item);  
  917.             VAR y:item; op:symbol; (* ts:typset; (LN) *)
  918.  
  919.             PROCEDURE factor(fsys:symset; VAR x:item);  
  920.               VAR i,f: integer; 
  921.  
  922.               PROCEDURE standfct(n: integer);
  923.                  VAR ts: typset;
  924.               BEGIN (*standard function no. n*) 
  925.                 IF sy = lparent THEN insymbol ELSE error(9);
  926.                 IF n < 17 THEN  
  927.                   BEGIN expression(fsys+[rparent],x);
  928.                     CASE n OF
  929. (*abs,sqr*)     0,2: BEGIN ts := [ints,reals]; tab[i].typ := x.typ; 
  930.                        IF x.typ = reals THEN n := n+1
  931.                      END ;  
  932. (*odd,chr*)     4,5: ts := [ints];  
  933. (*ord*)         6:   ts := [ints,bools,chars];  
  934. (*succ,pred*)   7,8: BEGIN ts := [ints,bools,chars]; tab[i].typ := x.typ
  935.                      END ;  
  936. (*round,trunc*) 9,10,11,12,13,14,15,16: 
  937. (*sin,cos,...*)      BEGIN ts := [ints,reals];  
  938.                          IF x.typ = ints THEN emit1(26,0)
  939.                      END ;  
  940.                     END ;
  941.                     IF x.typ IN ts THEN emit1(8,n) ELSE 
  942.                     IF x.typ <> notyp THEN error(48);
  943.                   END ELSE  
  944. (*eof,eoln*)      BEGIN (*n in [17,18]*)
  945.                     IF sy <> ident THEN error(2) ELSE
  946.                     IF id <> 'input       ' THEN error(0) ELSE insymbol;
  947.                     emit1(8,n); 
  948.                   END ; 
  949.                 x.typ := tab[i].typ;
  950.                 IF sy = rparent THEN insymbol ELSE error(4) 
  951.               END (*standfct*) ;
  952.  
  953.             BEGIN (*factor*) x.typ := notyp; x.ref := 0;
  954.               test(facbegsys, fsys, 58);
  955.               WHILE sy IN facbegsys DO  
  956.                 BEGIN
  957.                   IF sy = ident THEN
  958.                   BEGIN i := loc(id); insymbol; 
  959.                     WITH tab[i] DO  
  960.                     CASE obj OF 
  961.               konstant: BEGIN x.typ := typ; x.ref := 0; 
  962.                           IF x.typ = reals THEN 
  963.                             emit1(25,adr) ELSE  
  964.                             emit1(24,adr)
  965.                         END ;
  966.               variable: BEGIN x.typ := typ; x.ref := ref;
  967.                           IF sy IN [lbrack,lparent,period] THEN 
  968.                             BEGIN IF normal THEN f := 0 ELSE f := 1;
  969.                               emit2(f, lev, adr);
  970.                               selector(fsys,x); 
  971.                               IF x.typ IN stantyps THEN emit(34)
  972.                             END ELSE
  973.                             BEGIN
  974.                               IF x.typ IN stantyps THEN 
  975.                                 IF normal THEN f := 1 ELSE f := 2
  976.                               ELSE  
  977.                                 IF normal THEN f := 0 ELSE f := 1;  
  978.                               emit2(f, lev, adr)
  979.                             END 
  980.                         END ;
  981.               type1, prozedure:    error(44);
  982.               funktion :BEGIN x.typ := typ; 
  983.                           IF lev <> 0 THEN call(fsys, i)
  984.                                 ELSE standfct(adr)  
  985.                         END 
  986.                     END (*case,with*)
  987.                   END ELSE  
  988.                   IF sy IN [charcon,intcon,realcon] THEN
  989.                    BEGIN
  990.                      IF sy = realcon THEN
  991.                      BEGIN x.typ := reals; enterreal(rnum); 
  992.                        emit1(25, c1)
  993.                      END ELSE
  994.                      BEGIN IF sy = charcon THEN x.typ := chars  
  995.                                            ELSE x.typ := ints;  
  996.                        emit1(24, inum)  
  997.                      END ;  
  998.                      x.ref := 0; insymbol
  999.                    END ELSE 
  1000.                   IF sy = lparent THEN  
  1001.                    BEGIN insymbol; expression(fsys+[rparent], x);
  1002.                      IF sy = rparent THEN insymbol ELSE error(4)
  1003.                    END ELSE 
  1004.                   IF sy = notsy THEN
  1005.                    BEGIN insymbol; factor(fsys,x);  
  1006.                      IF x.typ=bools THEN emit(35) ELSE  
  1007.                        IF x.typ<>notyp THEN error(32)
  1008.                    END ;
  1009.                   test(fsys, facbegsys, 6)  
  1010.                 END (*while*)
  1011.             END (*factor*) ;
  1012.  
  1013.           BEGIN (*term*)
  1014.             factor(fsys+[times,rdiv,idiv,imod,andsy], x);
  1015.             WHILE sy IN [times,rdiv,idiv,imod,andsy] DO 
  1016.               BEGIN op := sy; insymbol; 
  1017.                 factor(fsys+[times,rdiv,idiv,imod,andsy], y);
  1018.                 IF op = times THEN  
  1019.                 BEGIN x.typ := resulttype(x.typ, y.typ);
  1020.                   CASE x.typ OF 
  1021.                     notyp: ;
  1022.                     ints : emit(57);
  1023.                     reals: emit(60);
  1024.                   END
  1025.                 END ELSE
  1026.                 IF op = rdiv THEN
  1027.                 BEGIN
  1028.                   IF x.typ = ints THEN  
  1029.                     BEGIN emit1(26,1); x.typ := reals
  1030.                     END ;
  1031.                   IF y.typ = ints THEN  
  1032.                     BEGIN emit1(26,0); y.typ := reals
  1033.                     END ;
  1034.                   IF (x.typ=reals) AND (y.typ=reals) THEN emit(61) ELSE 
  1035.                     BEGIN IF (x.typ<>notyp) AND (y.typ<>notyp) THEN 
  1036.                             error(33);  
  1037.                           x.typ := notyp
  1038.                     END 
  1039.                 END ELSE
  1040.                 IF op = andsy THEN  
  1041.                 BEGIN IF (x.typ=bools) AND (y.typ=bools) THEN
  1042.                          emit(56) ELSE  
  1043.                       BEGIN IF (x.typ<>notyp) AND (y.typ<>notyp) THEN
  1044.                                error(32);
  1045.                          x.typ := notyp 
  1046.                       END
  1047.                 END ELSE
  1048.                 BEGIN (*op in [idiv,imod]*) 
  1049.                   IF (x.typ=ints) AND (y.typ=ints) THEN 
  1050.                     IF op=idiv THEN emit(58)
  1051.                                ELSE emit(59) ELSE
  1052.                     BEGIN IF (x.typ<>notyp) AND (y.typ<>notyp) THEN 
  1053.                              error(34); 
  1054.                           x.typ := notyp
  1055.                     END 
  1056.                 END 
  1057.               END
  1058.           END (*term*) ;
  1059.  
  1060.         BEGIN (*simpleexpression*)  
  1061.           IF sy IN [plus,minus] THEN
  1062.             BEGIN op := sy; insymbol;
  1063.               term(fsys+[plus,minus], x);
  1064.               IF x.typ > reals THEN error(33) ELSE  
  1065.                 IF op = minus THEN emit(36) 
  1066.             END ELSE
  1067.           term(fsys+[plus,minus,orsy], x);  
  1068.           WHILE sy IN [plus,minus,orsy] DO  
  1069.             BEGIN op := sy; insymbol;
  1070.                term(fsys+[plus,minus,orsy], y); 
  1071.                IF op = orsy THEN
  1072.                BEGIN
  1073.                  IF (x.typ=bools) AND (y.typ=bools) THEN emit(51) ELSE  
  1074.                    BEGIN IF (x.typ<>notyp) AND (y.typ<>notyp) THEN  
  1075.                             error(32);  
  1076.                          x.typ := notyp 
  1077.                    END  
  1078.                END ELSE 
  1079.                BEGIN x.typ := resulttype(x.typ, y.typ); 
  1080.                  CASE x.typ OF  
  1081.                    notyp: ; 
  1082.                    ints : IF op = plus THEN emit(52)
  1083.                                    ELSE emit(53);
  1084.                    reals: IF op = plus THEN emit(54)
  1085.                                    ELSE emit(55)
  1086.                  END
  1087.                END  
  1088.             END 
  1089.         END (*simpleexpression*) ;  
  1090.  
  1091.       BEGIN (*expression*)  
  1092.         simpleexpression(fsys+[eql,neq,lss,leq,gtr,geq], x);
  1093.         IF sy IN [eql,neq,lss,leq,gtr,geq] THEN 
  1094.           BEGIN op := sy; insymbol; simpleexpression(fsys, y);  
  1095.              IF (x.typ IN [notyp,ints,bools,chars]) 
  1096.                AND (x.typ = y.typ) THEN 
  1097.                CASE op OF
  1098.                  eql: emit(45); 
  1099.                  neq: emit(46); 
  1100.                  lss: emit(47); 
  1101.                  leq: emit(48); 
  1102.                  gtr: emit(49); 
  1103.                  geq: emit(50); 
  1104.                END ELSE 
  1105.              BEGIN IF x.typ = ints THEN 
  1106.                      BEGIN x.typ := reals; emit1(26,1)  
  1107.                      END ELSE
  1108.                    IF y.typ = ints THEN 
  1109.                      BEGIN y.typ := reals; emit1(26,0)  
  1110.                      END ;  
  1111.                IF (x.typ=reals) AND (y.typ=reals) THEN  
  1112.                  CASE op OF 
  1113.                    eql: emit(39);
  1114.                    neq: emit(40);
  1115.                    lss: emit(41);
  1116.                    leq: emit(42);
  1117.                    gtr: emit(43);
  1118.                    geq: emit(44);
  1119.                  END
  1120.                ELSE error(35)
  1121.              END ;  
  1122.              x.typ := bools 
  1123.           END
  1124.       END (*expression*) ;  
  1125.  
  1126.       PROCEDURE assignment(lv,ad: integer); 
  1127.          VAR x,y: item; f: integer; 
  1128.          (*tab[i].obj in [variable,prozedure]*) 
  1129.       BEGIN x.typ := tab[i].typ; x.ref := tab[i].ref;
  1130.         IF tab[i].normal THEN f := 0 ELSE f := 1;
  1131.         emit2(f, lv, ad);
  1132.         IF sy IN [lbrack,lparent,period] THEN
  1133.            selector([becomes,eql]+fsys, x); 
  1134.         IF sy = becomes THEN insymbol ELSE  
  1135.           BEGIN error(51); IF sy = eql THEN insymbol
  1136.           END ; 
  1137.         expression(fsys, y);
  1138.         IF x.typ = y.typ THEN
  1139.           IF x.typ IN stantyps THEN emit(38) ELSE
  1140.           IF x.ref <> y.ref THEN error(46) ELSE 
  1141.           IF x.typ = arrays THEN emit1(23, atab[x.ref].size)
  1142.                             ELSE emit1(23, btab[x.ref].vsize)
  1143.         ELSE
  1144.         IF (x.typ=reals) AND (y.typ=ints) THEN  
  1145.           BEGIN emit1(26,0); emit(38)
  1146.           END ELSE  
  1147.           IF (x.typ<>notyp) AND (y.typ<>notyp) THEN error(46)
  1148.       END (*assignment*) ;  
  1149.  
  1150.       PROCEDURE compoundstatement;  
  1151.       BEGIN insymbol;
  1152.         statement([semicolon,endsy]+fsys);  
  1153.         WHILE sy IN [semicolon]+statbegsys DO
  1154.         BEGIN IF sy = semicolon THEN insymbol ELSE error(14);
  1155.           statement([semicolon,endsy]+fsys) 
  1156.         END ;
  1157.         IF sy = endsy THEN insymbol ELSE error(57)  
  1158.       END (*compoundstatemenet*) ;  
  1159.  
  1160.       PROCEDURE ifstatement;
  1161.          VAR x: item; lc1,lc2: integer; 
  1162.       BEGIN insymbol;
  1163.         expression(fsys+[thensy,dosy], x);  
  1164.         IF NOT (x.typ IN [bools,notyp]) THEN error(17); 
  1165.         lc1 := lc; emit(11);  (*jmpc*)  
  1166.         IF sy = thensy THEN insymbol ELSE
  1167.           BEGIN error(52); IF sy = dosy THEN insymbol
  1168.           END ; 
  1169.         statement(fsys+[elsesy]);
  1170.         IF sy = elsesy THEN 
  1171.           BEGIN insymbol; lc2 := lc; emit(10);  
  1172.             code[lc1].y := lc; statement(fsys); code[lc2].y := lc
  1173.           END
  1174.         ELSE code[lc1].y := lc  
  1175.       END (*ifstatement*) ; 
  1176.  
  1177.       PROCEDURE casestatement;  
  1178.         VAR x: item;
  1179.             i,j,k,lc1: integer; 
  1180.             casetab: ARRAY [1..csmax] OF
  1181.                        PACKED RECORD val, lc: index END ;
  1182.             exittab: ARRAY [1..csmax] OF integer;
  1183.  
  1184.         PROCEDURE caselabel;
  1185.           VAR lab: conrec; k: integer;  
  1186.         BEGIN constant(fsys+[comma,colon], lab);
  1187.           IF lab.tp <> x.typ THEN error(47) ELSE
  1188.           IF i = csmax THEN fatal(6) ELSE
  1189.             BEGIN i := i+1; k := 0; 
  1190.               casetab[i].val := lab.i; casetab[i].lc := lc; 
  1191.               REPEAT k := k+1 UNTIL casetab[k].val = lab.i; 
  1192.               IF k < i THEN error(1);   (*multiple definition*) 
  1193.             END 
  1194.         END (*caselabel*) ; 
  1195.  
  1196.         PROCEDURE onecase;  
  1197.         BEGIN IF sy IN constbegsys THEN 
  1198.           BEGIN caselabel;  
  1199.             WHILE sy = comma DO 
  1200.               BEGIN insymbol; caselabel 
  1201.               END ; 
  1202.             IF sy = colon THEN insymbol ELSE error(5);  
  1203.             statement([semicolon,endsy]+fsys);  
  1204.             j := j+1; exittab[j] := lc; emit(10)
  1205.           END
  1206.         END (*onecase*) ;
  1207.  
  1208.       BEGIN insymbol; i := 0; j := 0;
  1209.         expression(fsys+[ofsy,comma,colon], x); 
  1210.         IF NOT (x.typ IN [ints,bools,chars,notyp]) THEN error(23);  
  1211.         lc1 := lc; emit(12);  (*jmpx*)  
  1212.         IF sy = ofsy THEN insymbol ELSE error(8);
  1213.         onecase;
  1214.         WHILE sy = semicolon DO 
  1215.           BEGIN insymbol; onecase
  1216.           END ; 
  1217.         code[lc1].y := lc;  
  1218.         FOR k := 1 TO i DO  
  1219.           BEGIN emit1(13,casetab[k].val); emit1(13,casetab[k].lc)
  1220.           END ; 
  1221.         emit1(10,0);
  1222.         FOR k := 1 TO j DO code[exittab[k]].y := lc;
  1223.         IF sy = endsy THEN insymbol ELSE error(57)  
  1224.       END (*casestatement*) ;
  1225.       PROCEDURE repeatstatement;
  1226.          VAR x: item; lc1: integer; 
  1227.       BEGIN lc1 := lc;  
  1228.         insymbol; statement([semicolon,untilsy]+fsys);  
  1229.         WHILE sy IN [semicolon]+statbegsys DO
  1230.         BEGIN IF sy = semicolon THEN insymbol ELSE error(14);
  1231.           statement([semicolon,untilsy]+fsys)
  1232.         END ;
  1233.         IF sy = untilsy THEN
  1234.           BEGIN insymbol; expression(fsys, x);  
  1235.             IF NOT (x.typ IN [bools,notyp]) THEN error(17); 
  1236.             emit1(11,lc1)
  1237.           END
  1238.         ELSE error(53)  
  1239.       END (*repeatstatement*) ; 
  1240.  
  1241.       PROCEDURE whilestatement; 
  1242.          VAR x: item; lc1,lc2: integer; 
  1243.       BEGIN insymbol; lc1 := lc;
  1244.         expression(fsys+[dosy], x); 
  1245.         IF NOT (x.typ IN [bools,notyp]) THEN error(17); 
  1246.         lc2 := lc; emit(11);
  1247.         IF sy = dosy THEN insymbol ELSE error(54);  
  1248.         statement(fsys); emit1(10,lc1); code[lc2].y := lc
  1249.       END (*whilestatement*) ;  
  1250.  
  1251.       PROCEDURE forstatement;
  1252.          VAR cvt: types; x: item;
  1253.              i,f,lc1,lc2: integer;  
  1254.       BEGIN insymbol;
  1255.         IF sy = ident THEN  
  1256.           BEGIN i := loc(id); insymbol; 
  1257.             IF i = 0 THEN cvt := ints ELSE  
  1258.             IF tab[i].obj = variable THEN
  1259.               BEGIN cvt := tab[i].typ;  
  1260.                 IF NOT tab[i].normal THEN error(37) ELSE
  1261.                   emit2(0, tab[i].lev, tab[i].adr); 
  1262.                 IF NOT (cvt IN [notyp,ints,bools,chars]) THEN error(18) 
  1263.               END ELSE  
  1264.               BEGIN error(37); cvt := ints  
  1265.               END
  1266.           END ELSE skip([becomes,tosy,downtosy,dosy]+fsys, 2);  
  1267.         IF sy = becomes THEN
  1268.           BEGIN insymbol; expression([tosy,downtosy,dosy]+fsys, x); 
  1269.             IF x.typ <> cvt THEN error(19); 
  1270.           END ELSE skip([tosy,downtosy,dosy]+fsys, 51); 
  1271.         f := 14;
  1272.         IF sy IN [tosy, downtosy] THEN  
  1273.           BEGIN IF sy = downtosy THEN f := 16;  
  1274.             insymbol; expression([dosy]+fsys, x);
  1275.             IF x.typ <> cvt THEN error(19)  
  1276.           END ELSE skip([dosy]+fsys, 55);
  1277.         lc1 := lc; emit(f); 
  1278.         IF sy = dosy THEN insymbol ELSE error(54);  
  1279.         lc2 := lc; statement(fsys); 
  1280.         emit1(f+1,lc2); code[lc1].y := lc
  1281.       END (*forstatement*) ;
  1282.  
  1283.       PROCEDURE standproc(n: integer);  
  1284.          VAR i,f: integer;  
  1285.              x,y: item; 
  1286.       BEGIN 
  1287.         CASE n OF
  1288.    1,2: BEGIN (*read*)  
  1289.           IF NOT iflag THEN 
  1290.             BEGIN error(20); iflag := true  
  1291.             END ;
  1292.           IF sy = lparent THEN  
  1293.           BEGIN 
  1294.             REPEAT insymbol;
  1295.               IF sy <> ident THEN error(2) ELSE 
  1296.               BEGIN i := loc(id); insymbol; 
  1297.                 IF i <> 0 THEN  
  1298.                 IF tab[i].obj <> variable THEN error(37) ELSE
  1299.                 BEGIN x.typ := tab[i].typ; x.ref := tab[i].ref; 
  1300.                   IF tab[i].normal THEN f := 0 ELSE f := 1; 
  1301.                   emit2(f, tab[i].lev, tab[i].adr); 
  1302.                   IF sy IN [lbrack,lparent,period] THEN 
  1303.                     selector(fsys+[comma,rparent], x);  
  1304.                   IF x.typ IN [ints,reals,chars,notyp] THEN 
  1305.                     emit1(27, ord(x.typ)) ELSE error(41)
  1306.                 END 
  1307.               END ; 
  1308.               test([comma,rparent], fsys, 6);
  1309.             UNTIL sy <> comma;  
  1310.             IF sy = rparent THEN insymbol ELSE error(4) 
  1311.           END ; 
  1312.           IF n = 2 THEN emit(62)
  1313.         END ;
  1314.    3,4: BEGIN (*write*) 
  1315.           IF sy = lparent THEN  
  1316.           BEGIN 
  1317.             REPEAT insymbol;
  1318.               IF sy = string THEN
  1319.                 BEGIN emit1(24,sleng); emit1(28,inum); insymbol 
  1320.                 END ELSE
  1321.               BEGIN expression(fsys+[comma,colon,rparent], x);  
  1322.                 IF NOT (x.typ IN stantyps) THEN error(41);  
  1323.                 IF sy = colon THEN  
  1324.                 BEGIN insymbol; 
  1325.                   expression(fsys+[comma,colon,rparent], y);
  1326.                   IF y.typ <> ints THEN error(43);  
  1327.                   IF sy = colon THEN
  1328.                   BEGIN IF x.typ <> reals THEN error(42);
  1329.                     insymbol; expression(fsys+[comma,rparent], y);  
  1330.                     IF y.typ <> ints THEN error(43);
  1331.                     emit(37)
  1332.                   END
  1333.                   ELSE emit1(30, ord(x.typ))
  1334.                 END 
  1335.                 ELSE emit1(29, ord(x.typ))  
  1336.               END
  1337.             UNTIL sy <> comma;  
  1338.             IF sy = rparent THEN insymbol ELSE error(4) 
  1339.           END ; 
  1340.           IF n = 4 THEN emit(63)
  1341.         END ;
  1342.         END (*case*)
  1343.       END (*standproc*) ;
  1344.  
  1345.     BEGIN (*statement*) 
  1346.       IF sy IN statbegsys+[ident] THEN  
  1347.           CASE sy OF
  1348.             ident:    BEGIN i := loc(id); insymbol; 
  1349.                         IF i <> 0 THEN  
  1350.                         CASE tab[i].obj OF  
  1351.                           konstant, type1: error(45);
  1352.                           variable: assignment(tab[i].lev, tab[i].adr); 
  1353.                           prozedure:
  1354.                             IF tab[i].lev <> 0 THEN call(fsys, i)
  1355.                                     ELSE standproc(tab[i].adr); 
  1356.                           funktion: 
  1357.                             IF tab[i].ref = display[level] THEN 
  1358.                               assignment(tab[i].lev+1, 0) ELSE error(45)
  1359.                         END 
  1360.                       END ; 
  1361.             beginsy:  compoundstatement;
  1362.             ifsy:     ifstatement;  
  1363.             casesy:   casestatement;
  1364.             whilesy:  whilestatement;
  1365.             repeatsy: repeatstatement;  
  1366.             forsy:    forstatement; 
  1367.           END;  
  1368.         test(fsys, [], 14)  
  1369.     END (*statement*) ; 
  1370.  
  1371. BEGIN (*block*) dx := 5; prt := t;  
  1372.   IF level > lmax THEN fatal(5);
  1373.   test([lparent,colon,semicolon], fsys, 14);
  1374.   enterblock; display[level] := b; prb := b;
  1375.   tab[prt].typ := notyp; tab[prt].ref := prb;
  1376.   IF (sy = lparent) AND (level > 1) THEN parameterlist; 
  1377.   btab[prb].lastpar := t; btab[prb].psize := dx;
  1378.   IF isfun THEN 
  1379.     IF sy = colon THEN  
  1380.     BEGIN insymbol;   (*function type*) 
  1381.       IF sy = ident THEN
  1382.       BEGIN x := loc(id); insymbol; 
  1383.         IF x <> 0 THEN  
  1384.           IF tab[x].obj <> type1 THEN error(29) ELSE
  1385.             IF tab[x].typ IN stantyps THEN tab[prt].typ := tab[x].typ
  1386.               ELSE error(15)
  1387.       END ELSE skip([semicolon]+fsys, 2)
  1388.     END ELSE error(5);  
  1389.   IF sy = semicolon THEN insymbol ELSE error(14);
  1390.   REPEAT
  1391.     IF sy = constsy THEN constantdeclaration;
  1392.     IF sy = typesy THEN typedeclaration;
  1393.     IF sy = varsy THEN variabledeclaration; 
  1394.     btab[prb].vsize := dx;  
  1395.     WHILE sy IN [proceduresy,functionsy] DO procdeclaration;
  1396.     test([beginsy], blockbegsys+statbegsys, 56) 
  1397.   UNTIL sy IN statbegsys;
  1398.   tab[prt].adr := lc;
  1399.   insymbol; statement([semicolon,endsy]+fsys);  
  1400.   WHILE sy IN [semicolon]+statbegsys DO 
  1401.     BEGIN IF sy = semicolon THEN insymbol ELSE error(14);
  1402.       statement([semicolon,endsy]+fsys) 
  1403.     END ;
  1404.   IF sy = endsy THEN insymbol ELSE error(57);
  1405.   test(fsys+[period], [], 6)
  1406. END (*block*) ; 
  1407.  
  1408. (*-------------------------------------------------------interpret---*) 
  1409.  
  1410. PROCEDURE interpret;
  1411.   (*global code, tab, btab*)
  1412.   LABEL 98;   (*trap label*)
  1413.   VAR ir: order;      (*instruction buffer*)
  1414.       pc: integer;    (*program counter*)
  1415.       t:  integer;    (*top stack index*)
  1416.       b:  integer;    (*base index*)
  1417.       lncnt, ocnt, blkcnt, chrcnt: integer;     (*counters*)
  1418.       h1,h2,h3,h4: integer; 
  1419.       fld: ARRAY [1..4] OF integer;     (*default field widths*)
  1420.  
  1421.       display: ARRAY [1..lmax] OF integer;  
  1422.       s: ARRAY [1..stacksize] OF          (*blockmark:              *)  
  1423.          RECORD CASE types OF             (*   s[b+0] = fct result  *)  
  1424.            ints:  (i: integer);           (*   s[b+1] = return adr  *)  
  1425.            reals: (r: real);              (*   s[b+2] = static link *)  
  1426.            bools: (b: boolean);           (*   s[b+3] = dynamic link*)  
  1427.            chars: (c: char)               (*   s[b+4] = table index *)  
  1428.          END ;  
  1429.  
  1430. BEGIN (*interpret*) 
  1431.   s[1].i := 0; s[2].i := 0; s[3].i := -1; s[4].i := btab[1].last;
  1432.   b := 0; display[1] := 0;  
  1433.   t := btab[2].vsize - 1; pc := tab[s[4].i].adr;
  1434.   ps := run;
  1435.   lncnt := 0; ocnt := 0; chrcnt := 0;
  1436.   fld[1] := 10; fld[2] := 22; fld[3] := 10; fld[4] := 1;
  1437.   REPEAT ir := code[pc]; pc := pc+1; ocnt := ocnt + 1;  
  1438.     CASE ir.f OF
  1439.   0: BEGIN (*load address*) t := t+1;
  1440.        IF t > stacksize THEN ps := stkchk
  1441.          ELSE s[t].i := display[ir.x] + ir.y
  1442.      END ;  
  1443.   1: BEGIN (*load value*) t := t+1; 
  1444.        IF t > stacksize THEN ps := stkchk
  1445.          ELSE s[t] := s[display[ir.x] + ir.y]
  1446.      END ;  
  1447.   2: BEGIN (*load indirect*) t := t+1;  
  1448.        IF t > stacksize THEN ps := stkchk
  1449.          ELSE s[t] := s[s[display[ir.x] + ir.y].i]  
  1450.      END ;  
  1451.   3: BEGIN (*update display*)
  1452.        h1 := ir.y; h2 := ir.x; h3 := b; 
  1453.        REPEAT display[h1] := h3; h1 := h1-1; h3 := s[h3+2].i
  1454.        UNTIL h1 = h2
  1455.      END ;  
  1456.   8: CASE ir.y OF
  1457.       0: s[t].i := abs(s[t].i); 
  1458.       1: s[t].r := abs(s[t].r); 
  1459.       2: s[t].i := sqr(s[t].i); 
  1460.       3: s[t].r := sqr(s[t].r); 
  1461.       4: s[t].b := odd(s[t].i); 
  1462.       5: BEGIN (* s[t].c := chr(s[t].i); *) 
  1463.            IF (s[t].i < 0) OR (s[t].i > 63) THEN ps := inxchk
  1464.          END ;  
  1465.       6: (* s[t].i := ord(s[t].c) *);
  1466.       7: s[t].c := succ(s[t].c);
  1467.       8: s[t].c := pred(s[t].c);
  1468.       9: s[t].i := round(s[t].r);
  1469.      10: s[t].i := trunc(s[t].r);
  1470.      11: s[t].r := sin(s[t].r); 
  1471.      12: s[t].r := cos(s[t].r); 
  1472.      13: s[t].r := exp(s[t].r); 
  1473.      14: s[t].r := ln(s[t].r);  
  1474.      15: s[t].r := sqrt(s[t].r);
  1475.      16: s[t].r := arctan(s[t].r);  
  1476.      17: BEGIN t := t+1;
  1477.            IF t > stacksize THEN ps := stkchk ELSE s[t].b := eof(input) 
  1478.          END ;  
  1479.      18: BEGIN t := t+1;
  1480.            IF t > stacksize THEN ps := stkchk ELSE s[t].b := eoln(input)
  1481.          END ;  
  1482.      END ;  
  1483.   9: s[t].i := s[t].i + ir.y;   (*offset*)  
  1484.  10: pc := ir.y;  (*jump*)  
  1485.  11: BEGIN (*conditional jump*) 
  1486.        IF NOT s[t].b THEN pc := ir.y;  t := t-1 
  1487.      END ;  
  1488.  12: BEGIN (*switch*) h1 := s[t].i; t := t-1;
  1489.        h2 := ir.y; h3 := 0; 
  1490.        REPEAT IF code[h2].f <> 13 THEN  
  1491.                 BEGIN h3 := 1; ps := caschk 
  1492.                 END ELSE
  1493.               IF code[h2].y = h1 THEN
  1494.                 BEGIN h3 := 1; pc := code[h2+1].y
  1495.                 END ELSE
  1496.               h2 := h2 + 2  
  1497.        UNTIL h3 <> 0
  1498.      END ;  
  1499.  14: BEGIN (*for1up*) h1 := s[t-1].i;
  1500.        IF h1 <= s[t].i THEN s[s[t-2].i].i := h1 ELSE
  1501.           BEGIN t := t-3; pc := ir.y
  1502.           END
  1503.      END ;  
  1504.  15: BEGIN (*for2up*) h2 := s[t-2].i; h1 := s[h2].i + 1;
  1505.        IF h1 <= s[t].i THEN 
  1506.          BEGIN s[h2].i := h1; pc := ir.y END
  1507.        ELSE t := t-3;
  1508.      END ;  
  1509.  16: BEGIN (*for1down*) h1 := s[t-1].i; 
  1510.        IF h1 >= s[t].i THEN s[s[t-2].i].i := h1 ELSE
  1511.           BEGIN pc := ir.y; t := t-3
  1512.           END
  1513.      END ;  
  1514.  17: BEGIN (*for2down*) h2 := s[t-2].i; h1 := s[h2].i - 1;  
  1515.        IF h1 >= s[t].i THEN 
  1516.          BEGIN s[h2].i := h1; pc := ir.y END
  1517.        ELSE t := t-3;
  1518.      END ;  
  1519.  18: BEGIN (*mark stack*)  h1 := btab[tab[ir.y].ref].vsize; 
  1520.        IF t+h1 > stacksize THEN ps := stkchk ELSE
  1521.          BEGIN t := t+5; s[t-1].i := h1-1; s[t].i := ir.y
  1522.          END
  1523.      END ;  
  1524.  19: BEGIN (*call*) h1 := t - ir.y;  (*h1 points to base*)  
  1525.        h2 := s[h1+4].i;            (*h2 points to tab*) 
  1526.        h3 := tab[h2].lev; display[h3+1] := h1;  
  1527.        h4 := s[h1+3].i + h1;
  1528.        s[h1+1].i := pc; s[h1+2].i := display[h3]; s[h1+3].i := b;
  1529.        FOR h3 := t+1 TO h4 DO s[h3].i := 0; 
  1530.        b := h1; t := h4; pc := tab[h2].adr  
  1531.      END ;  
  1532.  20: BEGIN (*index1*) h1 := ir.y;      (*h1 points to atab*)
  1533.        h2 := atab[h1].low; h3 := s[t].i;
  1534.        IF h3 < h2 THEN ps := inxchk ELSE
  1535.        IF h3 > atab[h1].high THEN ps := inxchk ELSE 
  1536.          BEGIN t := t-1; s[t].i := s[t].i + (h3-h2) 
  1537.          END
  1538.      END ;  
  1539.  21: BEGIN (*index*)  h1 := ir.y;      (*h1 points to atab*)
  1540.        h2 := atab[h1].low; h3 := s[t].i;
  1541.        IF h3 < h2 THEN ps := inxchk ELSE
  1542.        IF h3 > atab[h1].high THEN ps := inxchk ELSE 
  1543.          BEGIN t := t-1; s[t].i := s[t].i + (h3-h2)*atab[h1].elsize 
  1544.          END
  1545.      END ;  
  1546.  22: BEGIN (*load block*) h1 := s[t].i; t := t-1;
  1547.        h2 := ir.y + t; IF h2 > stacksize THEN ps := stkchk ELSE 
  1548.        WHILE t < h2 DO  
  1549.          BEGIN t := t+1; s[t] := s[h1]; h1 := h1+1  
  1550.          END
  1551.      END ;  
  1552.  23: BEGIN (*copy block*) h1 := s[t-1].i;
  1553.        h2 := s[t].i; h3 := h1 + ir.y;
  1554.        WHILE h1 < h3 DO 
  1555.          BEGIN s[h1] := s[h2]; h1 := h1+1; h2 := h2+1
  1556.          END ;  
  1557.        t := t-2 
  1558.      END ;  
  1559.  24: BEGIN (*literal*) t := t+1;
  1560.        IF t > stacksize THEN ps := stkchk ELSE s[t].i := ir.y
  1561.      END ;  
  1562.  25: BEGIN (*load real*) t := t+1;  
  1563.        IF t > stacksize THEN ps := stkchk ELSE s[t].r := rconst[ir.y]
  1564.      END ;  
  1565.  26: BEGIN (*float*) h1 := t - ir.y; s[h1].r := s[h1].i 
  1566.      END ;  
  1567.  27: BEGIN (*read*) 
  1568.        IF eof(input) THEN ps := redchk ELSE 
  1569.           CASE ir.y OF  
  1570.            1: read(s[s[t].i].i);
  1571.            2: read(s[s[t].i].r);
  1572.            4: read(s[s[t].i].c);
  1573.           END ; 
  1574.        t := t-1 
  1575.      END ;  
  1576.  28: BEGIN (*write string*) 
  1577.        h1 := s[t].i; h2 := ir.y; t := t-1;  
  1578.        chrcnt := chrcnt+h1; IF chrcnt > lineleng THEN ps := lngchk; 
  1579.        REPEAT write(stab[h2]); h1 := h1-1; h2 := h2+1
  1580.        UNTIL h1 = 0 
  1581.      END ;  
  1582.  29: BEGIN (*write1*)
  1583.        chrcnt := chrcnt + fld[ir.y];
  1584.        IF chrcnt > lineleng THEN ps := lngchk ELSE  
  1585.        CASE ir.y OF 
  1586.         1: write(s[t].i: fld[1]);
  1587.         2: write(s[t].r: fld[2]);
  1588.         3: write(s[t].b: fld[3]);
  1589.         4: write(chr(s[t].i MOD 64));
  1590.        END ;
  1591.        t := t-1 
  1592.      END ;  
  1593.  30: BEGIN (*write2*)
  1594.        chrcnt := chrcnt + s[t].i;
  1595.        IF chrcnt > lineleng THEN ps := lngchk ELSE  
  1596.        CASE ir.y OF 
  1597.         1: write(s[t-1].i: s[t].i); 
  1598.         2: write(s[t-1].r: s[t].i); 
  1599.         3: write(s[t-1].b: s[t].i); 
  1600.         4: write(chr(s[t-1].i MOD 64): s[t].i); 
  1601.        END ;
  1602.        t := t-2 
  1603.      END ;  
  1604.  31: ps := fin; 
  1605.  32: BEGIN (*exit procedure*)
  1606.        t := b-1; pc := s[b+1].i; b := s[b+3].i  
  1607.      END ;  
  1608.  33: BEGIN (*exit function*)
  1609.        t := b; pc := s[b+1].i; b := s[b+3].i
  1610.      END ;  
  1611.  34: s[t] := s[s[t].i]; 
  1612.  35: s[t].b := NOT s[t].b;  
  1613.  36: s[t].i := - s[t].i;
  1614.  37: BEGIN chrcnt := chrcnt + s[t-1].i; 
  1615.        IF chrcnt > lineleng THEN ps := lngchk ELSE  
  1616.           write(s[t-2].r: s[t-1].i: s[t].i);
  1617.        t := t-3 
  1618.      END ;  
  1619.  38: BEGIN (*store*) s[s[t-1].i] := s[t]; t := t-2  
  1620.      END ;  
  1621.  39: BEGIN t := t-1; s[t].b := s[t].r = s[t+1].r
  1622.      END ;  
  1623.  40: BEGIN t := t-1; s[t].b := s[t].r <> s[t+1].r
  1624.      END ;  
  1625.  41: BEGIN t := t-1; s[t].b := s[t].r < s[t+1].r
  1626.      END ;  
  1627.  42: BEGIN t := t-1; s[t].b := s[t].r <= s[t+1].r
  1628.      END ;  
  1629.  43: BEGIN t := t-1; s[t].b := s[t].r > s[t+1].r
  1630.      END ;  
  1631.  44: BEGIN t := t-1; s[t].b := s[t].r >= s[t+1].r
  1632.      END ;  
  1633.  45: BEGIN t := t-1; s[t].b := s[t].i = s[t+1].i
  1634.      END ;  
  1635.  46: BEGIN t := t-1; s[t].b := s[t].i <> s[t+1].i
  1636.      END ;  
  1637.  47: BEGIN t := t-1; s[t].b := s[t].i < s[t+1].i
  1638.      END ;  
  1639.  48: BEGIN t := t-1; s[t].b := s[t].i <= s[t+1].i
  1640.      END ;  
  1641.  49: BEGIN t := t-1; s[t].b := s[t].i > s[t+1].i
  1642.      END ;  
  1643.  50: BEGIN t := t-1; s[t].b := s[t].i >= s[t+1].i
  1644.      END ;  
  1645.  51: BEGIN t := t-1; s[t].b := s[t].b OR s[t+1].b
  1646.      END ;  
  1647.  52: BEGIN t := t-1; s[t].i := s[t].i + s[t+1].i
  1648.      END ;  
  1649.  53: BEGIN t := t-1; s[t].i := s[t].i - s[t+1].i
  1650.      END ;  
  1651.  54: BEGIN t := t-1; s[t].r := s[t].r + s[t+1].r;
  1652.      END ;  
  1653.  55: BEGIN t := t-1; s[t].r := s[t].r - s[t+1].r;
  1654.      END ;  
  1655.  56: BEGIN t := t-1; s[t].b := s[t].b AND s[t+1].b  
  1656.      END ;  
  1657.  57: BEGIN t := t-1; s[t].i := s[t].i * s[t+1].i
  1658.      END ;  
  1659.  58: BEGIN t := t-1;
  1660.        IF s[t+1].i = 0 THEN ps := divchk ELSE
  1661.          s[t].i := s[t].i DIV s[t+1].i  
  1662.      END ;  
  1663.  59: BEGIN t := t-1;
  1664.        IF s[t+1].i = 0 THEN ps := divchk ELSE
  1665.          s[t].i := s[t].i MOD s[t+1].i  
  1666.      END ;  
  1667.  60: BEGIN t := t-1; s[t].r := s[t].r * s[t+1].r;
  1668.      END ;  
  1669.  61: BEGIN t := t-1; s[t].r := s[t].r / s[t+1].r;
  1670.      END ;  
  1671.  62: IF eof(input) THEN ps := redchk ELSE readln;
  1672.  63: BEGIN writeln; lncnt := lncnt + 1; chrcnt := 0;
  1673.         IF lncnt > linelimit THEN ps := linchk  
  1674.      END
  1675.     END (*case*) ;  
  1676.   UNTIL ps <> run;  
  1677.  
  1678. 98: IF ps <> fin THEN
  1679.   BEGIN writeln;
  1680.     write(' halt at', pc:5, ' because of ');
  1681.     CASE ps OF  
  1682.       run:    writeln('error (see dayfile)');
  1683.       caschk: writeln('undefined case');
  1684.       divchk: writeln('division by 0'); 
  1685.       inxchk: writeln('invalid index'); 
  1686.       stkchk: writeln('storage overflow');  
  1687.       linchk: writeln('too much output');
  1688.       lngchk: writeln('line too long'); 
  1689.       redchk: writeln('reading past end of file');  
  1690.       iopr  : writeln('illegal operation'); 
  1691.       igdm  : writeln('guard mode or undefined sequence');  
  1692.       ifof  : writeln('floating point overflow');
  1693.       ifuf  : writeln('floating point underflow');  
  1694.       idof  : writeln('divide fault (div. by zero or overflow)');
  1695.       ioerr : writeln('i/o call error');
  1696.       symberr:writeln('symbiont call error');
  1697.       errcall:writeln('call on err$');  
  1698.     END ;
  1699.     h1 := b; blkcnt := 10;   (*post mortem dump*)
  1700.     REPEAT writeln; blkcnt := blkcnt - 1;
  1701.       IF blkcnt = 0 THEN h1 := 0; h2 := s[h1+4].i;  
  1702.       IF h1<>0 THEN 
  1703.         writeln(' ', tab[h2].name, ' called at', s[h1+1].i: 5); 
  1704.       h2 := btab[tab[h2].ref].last; 
  1705.       WHILE h2 <> 0 DO  
  1706.       WITH tab[h2] DO
  1707.       BEGIN IF obj = variable THEN  
  1708.             IF typ IN stantyps THEN 
  1709.             BEGIN write('    ', name, ' = ');
  1710.               IF normal THEN h3 := h1+adr ELSE h3 := s[h1+adr].i;
  1711.               CASE typ OF
  1712.                ints:  writeln(s[h3].i); 
  1713.                reals: writeln(s[h3].r); 
  1714.                bools: writeln(s[h3].b); 
  1715.                chars: writeln(chr(s[h3].i MOD 64)); 
  1716.               END
  1717.             END ;
  1718.             h2 := link  
  1719.       END ; 
  1720.       h1 := s[h1+3].i
  1721.     UNTIL h1 < 0;
  1722.   END ; 
  1723.   writeln; writeln(ocnt, ' steps')  
  1724. END (*interpret*) ; 
  1725.  
  1726. (*------------------------------------------------------------main----*)
  1727.  
  1728. BEGIN (*main*)  
  1729.    writeln('--  pascal-s   --');writeln;
  1730.    key[ 1] := 'and         '; key[ 2] := 'array       ';
  1731.    key[ 3] := 'begin       '; key[ 4] := 'case        ';
  1732.    key[ 5] := 'const       '; key[ 6] := 'div         ';
  1733.    key[ 8] := 'downto      '; key[ 7] := 'do          ';
  1734.    key[ 9] := 'else        '; key[10] := 'end         ';
  1735.    key[11] := 'for         '; key[12] := 'function    ';
  1736.    key[13] := 'if          '; key[14] := 'mod         ';
  1737.    key[15] := 'not         '; key[16] := 'of          ';
  1738.    key[17] := 'or          '; key[18] := 'procedure   ';
  1739.    key[19] := 'program     '; key[20] := 'record      ';
  1740.    key[21] := 'repeat      '; key[22] := 'then        ';
  1741.    key[23] := 'to          '; key[24] := 'type        ';
  1742.    key[25] := 'until       '; key[26] := 'var         ';
  1743.    key[27] := 'while       ';
  1744.    ksy[ 1] := andsy;        ksy[ 2] := arraysy; 
  1745.    ksy[ 3] := beginsy;      ksy[ 4] := casesy;  
  1746.    ksy[ 5] := constsy;      ksy[ 6] := idiv;
  1747.    ksy[ 8] := downtosy;     ksy[ 7] := dosy;
  1748.    ksy[ 9] := elsesy;       ksy[10] := endsy;
  1749.    ksy[11] := forsy;        ksy[12] := functionsy;  
  1750.    ksy[13] := ifsy;         ksy[14] := imod;
  1751.    ksy[15] := notsy;        ksy[16] := ofsy;
  1752.    ksy[17] := orsy;         ksy[18] := proceduresy; 
  1753.    ksy[19] := programsy;    ksy[20] := recordsy;
  1754.    ksy[21] := repeatsy;     ksy[22] := thensy;  
  1755.    ksy[23] := tosy;         ksy[24] := typesy;  
  1756.    ksy[25] := untilsy;      ksy[26] := varsy;
  1757.    ksy[27] := whilesy;  
  1758.    sps['+'] := plus;        sps['-'] := minus;  
  1759.    sps['*'] := times;       sps['/'] := rdiv;
  1760.    sps['('] := lparent;     sps[')'] := rparent;
  1761.    sps['='] := eql;         sps[','] := comma;  
  1762.    sps['['] := lbrack;      sps[']'] := rbrack; 
  1763.    sps['"'] := neq;         sps['&'] := andsy;  
  1764.    sps[';'] := semicolon;
  1765.   constbegsys := [plus,minus,intcon,realcon,charcon,ident]; 
  1766.   typebegsys := [ident,arraysy,recordsy];
  1767.   blockbegsys := [constsy,typesy,varsy,proceduresy,functionsy,beginsy]; 
  1768.   facbegsys := [intcon,realcon,charcon,ident,lparent,notsy];
  1769.   statbegsys := [beginsy,ifsy,whilesy,repeatsy,forsy,casesy];
  1770.   stantyps := [notyp,ints,reals,bools,chars];
  1771.   lc := 0; ll := 0; cc := 0; ch := ' '; 
  1772.   errpos := 0; errs := [];  
  1773.   t := -1; a := 0; b := 1; sx := 0; c2 := 0;
  1774.   display[0] := 1; reset(input); insymbol;  
  1775.   iflag := false; oflag := false; skipflag := false;
  1776.   IF sy <> programsy THEN error(3) ELSE 
  1777.  BEGIN insymbol;
  1778.     IF sy <> ident THEN error(2) ELSE
  1779.     BEGIN progname := id; insymbol; 
  1780.       IF sy <> lparent THEN error(9) ELSE
  1781.       REPEAT insymbol;  
  1782.         IF sy <> ident THEN error(2) ELSE
  1783.         BEGIN IF id = 'input       ' THEN iflag := true ELSE
  1784.               IF id = 'output      ' THEN oflag := true ELSE error(0);  
  1785.            insymbol 
  1786.         END 
  1787.       UNTIL sy <> comma;
  1788.       IF sy = rparent THEN insymbol ELSE error(4);  
  1789.       IF NOT oflag THEN error(20)
  1790.     END 
  1791.   END ; 
  1792.   enter('            ', variable, notyp, 0);  (*sentinel*)  
  1793.   enter('false       ', konstant, bools, 0);
  1794.   enter('true        ', konstant, bools, 1);
  1795.   enter('real        ', type1, reals, 1);
  1796.   enter('char        ', type1, chars, 1);
  1797.   enter('boolean     ', type1, bools, 1);
  1798.   enter('integer     ', type1, ints , 1);
  1799.   enter('abs         ', funktion, reals,0); 
  1800.   enter('sqr         ', funktion, reals,2); 
  1801.   enter('odd         ', funktion, bools,4); 
  1802.   enter('chr         ', funktion, chars,5); 
  1803.   enter('ord         ', funktion, ints, 6); 
  1804.   enter('succ        ', funktion, chars,7); 
  1805.   enter('pred        ', funktion, chars,8); 
  1806.   enter('round       ', funktion, ints, 9); 
  1807.   enter('trunc       ', funktion, ints, 10);
  1808.   enter('sin         ', funktion, reals, 11);
  1809.   enter('cos         ', funktion, reals, 12);
  1810.   enter('exp         ', funktion, reals, 13);
  1811.   enter('ln          ', funktion, reals, 14);
  1812.   enter('sqrt        ', funktion, reals, 15);
  1813.   enter('arctan      ', funktion, reals, 16);
  1814.   enter('eof         ', funktion, bools, 17);
  1815.   enter('eoln        ', funktion, bools, 18);
  1816.   enter('read        ', prozedure, notyp, 1);
  1817.   enter('readln      ', prozedure, notyp, 2);
  1818.   enter('write       ', prozedure, notyp, 3);
  1819.   enter('writeln     ', prozedure, notyp, 4);
  1820.   enter('            ', prozedure, notyp, 0);
  1821.   WITH btab[1] DO
  1822.     BEGIN last := t; lastpar := 1; psize := 0; vsize := 0
  1823.     END ;
  1824.  
  1825.   block(blockbegsys+statbegsys, false, 1);  
  1826.   IF sy <> period THEN error(22);
  1827.   emit(31);  (*halt*)
  1828.   IF btab[2].vsize > stacksize THEN error(49);  
  1829.   IF progname = 'test0       ' THEN printtables;
  1830.  
  1831.   IF errs = [] THEN 
  1832.   BEGIN 
  1833.     IF iflag THEN
  1834.       IF eof(input) THEN writeln(' input data missing')     ;
  1835.     writeln(' (eof)'); writeln; 
  1836.     interpret
  1837.   END
  1838.   ELSE errormsg;
  1839. 99: writeln 
  1840. END .
  1841.  
  1842.  
  1843.